home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / DEMOS / LWGTRSRC.ZIP / LWGTRSRC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-05-21  |  17.3 KB  |  519 lines
  1. (* 
  2.   This piece of sourcecode is meant for "educational" purposes, in other
  3.   words, don't rip the entire source to make a full LawGator clone.
  4.  
  5.   Pieces of this code may be used, but give credit where credit is due.
  6.  
  7.   There are some comments in the source, but without knowledge of pascal
  8.   and a lot of knowledge of RA you won't get really far...
  9.  
  10.   Grtx, MadCat
  11. *)
  12. Uses Radu,RaStruct,MiscRadu;
  13. Const
  14.   MaxAreas = 1400;                                           { Maximum areas }
  15. Type
  16.   ListerRecord = record
  17.                    Name : string[40];                            { Area Name }
  18.                    Nr   : word;                                { Area Number }
  19.                  End;
  20.   ListerType = array[1..MaxAreas] of ListerRecord;
  21.   GConfigRecord = record
  22.                     PageLen : byte;             { How much names on one page }
  23.                     LineLen : byte;                 { How long can a name be }
  24.                     Text    : array[1..2] of byte;           { Color of text }
  25.                     Bar     : array[1..2] of byte;       { Color of Menu bar }
  26.                     WPos    : array[1..2] of byte;         { Starting at X,Y }
  27.                     Free    : array[1..28] of byte;             { Free space }
  28.                   End;
  29. Var
  30.   List          : ^ListerType;
  31.   Mailing       : Boolean;                         { Doing mail groups/areas }
  32.   Filing        : Boolean;                         { Doing file groups/areas }
  33.   AreaOnly      : Boolean;                          { Only select from areas }
  34.   Centering     : Boolean;                                     { Center text }
  35.   Config        : GConfigrecord;
  36.   TempResult    : word;
  37.   TempSelection : word;
  38.   Dummy         : byte;
  39.   CurGroup      : word;
  40.  
  41. Label SelectFileGroup,SelectMailGroup;
  42.  
  43. Procedure Color(fg,bg: byte); { Used to set fg and bg color with one command }
  44. Begin
  45.   TextColor(fg);
  46.   TextBackGround(bg);
  47. End;
  48.  
  49. { This function strips a parameter from the leading character (these are:
  50.   "/" or "-") if found }
  51. Function StripParam(S: string): string;
  52. Begin
  53.   If (s[1]='-') or (s[1]='/') then Delete(s,1,1);
  54.   StripParam :=s;
  55. End;
  56.  
  57. Procedure ParseParams;                                { The parameter parser }
  58. Var
  59.   Tel : byte;
  60. Begin
  61.   Filing :=TRUE;                           { If no param found, assume files }
  62.   Mailing :=FALSE;                                       { See prev. comment }
  63.   AreaOnly :=FALSE;                   { If no param found, assume areas only }
  64.   Centering :=FALSE;                                  { No centering of text }
  65.   If ParamCount=0 then Exit;  { No params found so no need for further crap }
  66.   For Tel :=1 to ParamCount do
  67.   Begin
  68.     If SUpCase(StripParam(ParamStr(tel)))='CENTER' then Centering :=TRUE;
  69.     If SUpCase(StripParam(ParamStr(tel)))='MAIL' then
  70.     Begin
  71.       Mailing :=TRUE;
  72.       Filing :=FALSE;
  73.     End;
  74.     If SUpCase(StripParam(ParamStr(tel)))='FILE' then
  75.     Begin
  76.       Filing :=TRUE;
  77.       Mailing :=FALSE;
  78.     End;
  79.     If SUpCase(StripParam(ParamStr(tel)))='AREA' then AreaOnly :=TRUE;
  80.   End;
  81. End;
  82.  
  83. Function AllocateMem: Boolean;                         { Initialize the list }
  84. Begin
  85.   AllocateMem :=FALSE;
  86.   If MaxAvail<SizeOf(List^) then Exit;                   { Not enough memory }
  87.   New(List);
  88.   FillChar(List^,SizeOf(List^),0);                              { Empty list }
  89.   AllocateMem :=TRUE;
  90. End;
  91.  
  92. { The following function reads the group file "FGROUPS.RA" or "MGROUPS.RA"
  93.   since their structure is the same.
  94.  
  95.   If the parameter "Files" is true, read "FGROUPS.RA".
  96.  
  97.   Returns "FALSE" if files couldn't be read or error occured
  98. }
  99. Function ReadGroups(Files: Boolean): Boolean;
  100. Var
  101.   Temp      : GroupRecord;
  102.   GroupFile : File Of GroupRecord;
  103.   Tel       : word;                                      { The record number }
  104.   Ins       : word;                                       { The list counter }
  105. Begin
  106.   ReadGroups :=FALSE;
  107.   If Files then Assign(GroupFile,ForceBack(RaSystem)+'FGROUPS.RA')
  108.   else Assign(GroupFile,ForceBack(RaSystem)+'MGROUPS.RA');
  109.   {$i-}
  110.   Reset(GroupFile);
  111.   {$i+}
  112.   If IOResult<>0 then Exit;
  113.   ReadGroups :=TRUE;
  114.   Tel :=0;
  115.   Ins :=1;
  116.   While (not Eof(GroupFile)) and (Tel<>1399) do
  117.   Begin
  118.     Seek(GroupFile,Tel);                               { For added precision }
  119.     Read(GroupFile,Temp);
  120.     If Temp.Name<>'' then                                { Group isn't empty }
  121.     Begin
  122.       if Temp.Security<=ExitInfo.UserInfo.Security then    { User can select }
  123.       Begin
  124.         List^[ins].Name :=Copy(Temp.Name,1,Config.LineLen);
  125.         List^[ins].Nr :=tel+1;                     { The actual group number }
  126.         Inc(Ins);                         { Point to next free entry in list }
  127.       End;
  128.     End;
  129.     Inc(tel);                                             { Read next record }
  130.   End;
  131.   Close(GroupFile);
  132. End;
  133.  
  134. Function ReadFileAreas: Boolean;                   { Same idea as ReadGroups }
  135. Var
  136.   Tel     : word;
  137.   Ins     : word;
  138.   Temp    : FilesRecord;
  139.   FileFile: File of FilesRecord;
  140. Begin
  141.   ReadFileAreas :=FALSE;
  142.   Assign(FileFile,ForceBack(RaSystem)+'FILES.RA');
  143.   {$i-}
  144.   Reset(FileFile);
  145.   {$i+}
  146.   If IOResult<>0 then Exit;
  147.   ReadFileAreas :=TRUE;
  148.   Tel :=0;
  149.   Ins :=1;
  150.   While (not Eof(FileFile)) and (tel<>1399) do
  151.   Begin
  152.     Seek(FileFile,Tel);
  153.     Read(FileFile,Temp);
  154.     If Temp.Name<>'' then
  155.     Begin
  156.       If (Temp.Group=CurGroup) or (Temp.AltGroup[1]=CurGroup) or (temp.AltGroup[2]=CurGroup) or (Temp.AltGroup[3]=CurGroup)
  157.       or (Temp.Attrib2=1) then if (temp.Security<=ExitInfo.userInfo.Security) then
  158.       { The above 2 lines check if the area is in the current group and if
  159.         the user has axx to that area }
  160.       Begin
  161.         List^[Ins].Name :=Copy(Temp.Name,1,Config.LineLen);
  162.         List^[Ins].Nr :=tel+1;
  163.         Inc(Ins);
  164.       End;
  165.     End;
  166.     Inc(Tel);
  167.   End;
  168.   Close(FileFile);
  169. End;
  170.  
  171. Function ReadMailAreas: Boolean;                   { Same idea as ReadGroups }
  172. Var
  173.   Tel     : word;
  174.   Ins     : word;
  175.   Temp    : MessageRecord;
  176.   MailFile: File of MessageRecord;
  177. Begin
  178.   ReadMailAreas :=FALSE;
  179.   Assign(MailFile,ForceBack(RaSystem)+'MESSAGES.RA');
  180.   {$i-}
  181.   Reset(MailFile);
  182.   {$i+}
  183.   If IOResult<>0 then Exit;
  184.   ReadMailAreas :=TRUE;
  185.   Tel :=0;
  186.   Ins :=1;
  187.   While (Not Eof(MailFile)) and (tel<>1399) do
  188.   Begin
  189.     Seek(MailFile,tel);
  190.     Read(MailFile,Temp);
  191.     If Temp.Name<>'' then
  192.     Begin
  193.       If (Temp.Group=CurGroup) or (Temp.AltGroup[1]=CurGroup) or (temp.AltGroup[2]=CurGroup) or (Temp.AltGroup[3]=CurGroup)
  194.       or (Temp.Attribute2=1) then If (temp.WriteSecurity<=ExitInfo.UserInfo.Security)
  195.       { The above 2 lines check if the area is in the current group and
  196.         if the user has axx to that area }
  197.       and (Temp.ReadSecurity<=ExitInfo.UserInfo.Security) then
  198.       Begin
  199.         List^[Ins].Name :=Copy(Temp.Name,1,Config.LineLen);
  200.         List^[ins].Nr :=tel+1;
  201.         Inc(Ins);
  202.       End;
  203.     End;
  204.     Inc(Tel);
  205.   End;
  206.   Close(MailFile);
  207. End;
  208.  
  209. Procedure ClearList;                        { This procedure clears the list }
  210. Begin
  211.   FillChar(List^,SizeOf(List^),0);
  212. End;
  213.  
  214. Function GetMaxPage: Word;             { Get the amount of pages in the list }
  215. Var
  216.   Tel : word;
  217.   Ctr : byte;
  218.   Page: word;
  219. Begin
  220.   Page :=1;
  221.   Ctr :=0;
  222.   For Tel :=1 to 1400 do
  223.   Begin
  224.     If List^[tel].Name<>'' then Inc(Ctr);    { Entry isn't empty so increase }
  225.     if Ctr-1=Config.PageLen then                           { Okay, next page }
  226.     Begin
  227.       Ctr :=0;
  228.       Inc(Page);
  229.     End;
  230.   End;
  231.   GetMaxPage :=Page;
  232. End;
  233.  
  234. Function Expand(s: string;len: byte): string;    { Expands a string to "len" }
  235. Begin
  236.   While length(s)<len do s:=s+' ';
  237.   Expand :=s;
  238. End;
  239.  
  240. Procedure CenterWriteLn(X1,X2,Y: byte;s: string); { Guess =] }
  241. Var
  242.   len : byte;
  243.   a   : byte;
  244.   tel : byte;
  245. Begin
  246.   len :=x2-x1;
  247.   if length(s)>len then delete(s,len,length(s)-len+1);       { write between }
  248.   a :=(len div 2)-(length(s) div 2);                       { start text here }
  249.   GotoXy(x1,y);
  250.   for tel :=1 to a do write(' ');
  251.   Write(s);
  252.   while wherex<>x2 do write(' ');
  253. End;
  254.  
  255. { The following procedure displays a complete page. The variable "PageLimit"
  256.   returns the number of entrys displayed on the page }
  257. Procedure DisplayPage(Page: byte;Var PageLimit: byte);
  258. Var
  259.   Tel : word;
  260. Begin
  261.   Color(Config.Text[1],Config.Text[2]);
  262.   PageLimit :=0;
  263.   For Tel :=1 to Config.PageLen do
  264.   Begin
  265.     With Config do GotoXy(WPos[1],WPos[2]+tel-1);
  266.     If List^[(Page*Config.PageLen)-Config.PageLen+Tel].Name<>'' then
  267.     Begin
  268.       If Not Centering then WriteLn(Expand(List^[(Page*Config.PageLen)-Config.PageLen+Tel].Name,Config.LineLen))
  269.       else With Config do
  270.       CenterWriteLn(WPos[1],WPos[1]+LineLen,WPos[2]+Tel-1,List^[(Page*Config.PageLen)-Config.PageLen+Tel].Name);
  271.       Inc(PageLimit);
  272.     End else WriteLn(Expand(' ',Config.LineLen));
  273.   End;
  274. End;
  275.  
  276. Procedure ClearPageArea(StartX,StartY: byte);    { Clears the area of a page }
  277. Var
  278.   Tel : word;
  279.   Tel2: word;
  280. Begin
  281.   For Tel :=1 to Config.PageLen do
  282.   Begin
  283.     GotoXy(StartX,StartY+Tel-1);
  284.     Color(7,0);
  285.     For Tel2 :=1 to Config.LineLen do Write(' ');
  286.   End;
  287. End;
  288.  
  289. Function Lister_Selector(Var Result: byte): word;      { The actual selector }
  290. Var
  291.   MPos     : byte;                                         { Bar current pos }
  292.   Opos     : byte;                                           { Bar prev. pos }
  293.   Page     : word;                                            { Current page }
  294.   MaxPage  : word;                                              { Max. Pages }
  295.   PageLimit: byte;                                           { Lines on page }
  296.   Tel      : byte;                                 { <---\                   }
  297.   Ch       : Char;                                 { <-----\                 }
  298.   A        : byte;                                 { <------> Temporary stuff}
  299.   T        : string;                               { <-----/                 }
  300. Begin
  301.   With Config do ClearPageArea(WPos[1],WPos[2]);
  302.   MaxPage :=GetMaxPage;
  303.   MPos :=1;
  304.   OPos :=1;
  305.   Page :=1;
  306.   DisplayPage(Page,PageLimit);
  307.   With Config do GotoXy(WPos[1],WPos[2]+PageLen+1);
  308.   Write('`a8:[`a7:Page `a15:'+FStr(Page)+'`a7: of `a15:'+FStr(MaxPage)+'`a8:] [`a15:H`a8:]`a7:elp');
  309.   While True Do
  310.   Begin
  311.     Delay(10);
  312.     if OPos<>MPos then
  313.     Begin
  314.       Color(Config.Text[1],Config.Text[2]);
  315.       With Config do GotoXy(WPos[1],WPos[2]+OPos-1);
  316.       If Not Centering then WriteLn(Expand(List^[(Page*Config.PageLen)-Config.PageLen+OPos].Name,Config.LineLen))
  317.       else With Config do
  318.       CenterWriteLn(WPos[1],WPos[1]+LineLen,WPos[2]+OPos-1,List^[(Page*Config.PageLen)-Config.PageLen+OPos].Name);
  319.     End;
  320.     Color(Config.Bar[1],Config.Bar[2]);
  321.     With Config do GotoXy(WPos[1],WPos[2]+MPos-1);
  322.     If Not Centering then WriteLn(Expand(List^[(Page*Config.PageLen)-Config.PageLen+MPos].Name,Config.LineLen))
  323.     else With Config do
  324.     CenterWriteLn(WPos[1],WPos[1]+LineLen,WPos[2]+MPos-1,List^[(Page*Config.PageLen)-Config.PageLen+MPos].Name);
  325.     With Config do GotoXy(WPos[1]+LineLen-1,WPos[2]+MPos-1);
  326.     OPos :=MPos;
  327.     Delay(15);
  328.     Case UpCase(ReadKey) of
  329.       'H': Begin
  330.              Color(7,0);
  331.              ClrScr;
  332.              Write('`a1:`d196,80:');
  333.              WriteLn('`c:`a11:HELP');
  334.              Write('`a1:`d196,80:');
  335.              WriteLn;
  336.              WriteLn('`c:`a7:[`a15:`a7:]   `a11:- `a3:Move bar one position down ');
  337.              WriteLn('`c:`a7:[`a15:`a7:]   `a11:- `a3:Move bar one position up   ');
  338.              WriteLn('`c:`a7:[`a15:`a7:]   `a11:- `a3:Next Page (if any)         ');
  339.              WriteLn('`c:`a7:[`a15:`a7:]   `a11:- `a3:Previous Page (if any)     ');
  340.              WriteLn('`c:`a7:[`a15:ESC`a7:] `a11:- `a3:Back to BBS or one level up');
  341.              WriteLn('`c:`a7:[`a15:─┘`a7:] `a11:- `a3:Select Group/Area          ');
  342.              WriteLn;
  343.              WriteLn('`c:`a7:This program is `a15:probably`a7: the first and certainly');
  344.              WriteLn('`c:`a7:not the last that uses lightbars to select areas.');
  345.              WriteLn('`c:`a7:The idea (`a15:again`a7:) was taken from PCBoard, where');
  346.              WriteLn('`c:`a7:these utils are allready available.');
  347.              WriteLn;
  348.              Write('`a1:`d196,80:');
  349.              Write('`c:`a7:Press [`a15:ANY`a7:] key to continue:');
  350.              If ReadKey=#0 then ReadKey;
  351.              Color(7,0);
  352.              ClrScr;
  353.              If DorDisplay(ForceBack(DorPath)+'LAWGATOR.ANS','',FALSE)=#1 then RaLog('GATOR: No background found....');
  354.              DisplayPage(Page,PageLimit);
  355.              With Config do GotoXy(WPos[1],WPos[2]+PageLen+1);
  356.              Write('`a8:[`a7:Page `a15:'+FStr(Page)+'`a7: of `a15:'+FStr(MaxPage)+'`a8:] [`a15:H`a8:]`a7:elp');
  357.            End;
  358.       #0 : Case ReadKey of
  359.             #72: If MPos>1 then Dec(Mpos) else MPos :=PageLimit;
  360.             #80: if MPos<PageLimit then Inc(Mpos) else MPos :=1;
  361.             #75: If Page>1 then
  362.                  Begin
  363.                    Dec(Page);
  364.                    {With Config do ClearPageArea(WPos[1],WPos[2]);}
  365.                    DisplayPage(Page,PageLimit);
  366.                    With Config do GotoXy(WPos[1],WPos[2]+PageLen+1);
  367.                    Write('`a8:[`a7:Page `a15:'+FStr(Page)+'`a7: of `a15:'+FStr(MaxPage)+'`a8:] [`a15:H`a8:]`a7:elp');
  368.                    MPos :=PageLimit;
  369.                    OPos :=PageLimit;
  370.                  End;
  371.             #77: If Page<MaxPage then
  372.                  Begin
  373.                    Inc(Page);
  374.                    {With Config do ClearPageArea(WPos[1],WPos[2]);}
  375.                    DisplayPage(Page,PageLimit);
  376.                    With Config do GotoXy(WPos[1],WPos[2]+PageLen+1);
  377.                    Write('`a8:[`a7:Page `a15:'+FStr(Page)+'`a7: of `a15:'+FStr(MaxPage)+'`a8:] [`a15:H`a8:]`a7:elp');
  378.                    MPos :=1;
  379.                    OPos :=1;
  380.                  End;
  381.            End;
  382.      #27:  Begin
  383.              Lister_Selector :=0;
  384.              Result :=1;
  385.              Exit;
  386.            End;
  387.      #13:  Begin
  388.              Result :=0;
  389.              Lister_Selector :=List^[(Page*Config.PageLen)-Config.PageLen+MPos].Nr;
  390.              Exit;
  391.            End;
  392.     End;
  393.   End;
  394. End;
  395.  
  396. Function ReadConfig: Boolean;                            { Reads config file }
  397. Var
  398.   ConfigFile : File of GConfigRecord;
  399. Begin
  400.   Assign(ConfigFile,ForceBack(DorPath)+'LAWGATOR.CFG');
  401.   {$i-}
  402.   Reset(ConfigFile);
  403.   Read(ConfigFile,Config);
  404.   Close(ConfigFile);
  405.   {$i+}
  406.   ReadConfig :=(IOResult=0);
  407. End;
  408.  
  409. Begin
  410.   NoRalFoundErrorDisplay :=TRUE;
  411.   DorInit;
  412.   DorStatus(10);
  413.   LockStatus :=TRUE;
  414.   DorExtKeys[ExtKey_CtrlPgUp]:=DorExtKeys[ExtKey_Up];
  415.   DorExtKeys[ExtKey_CtrlPgDn]:=DorExtKeys[ExtKey_Down];
  416.   DorExtKeys[ExtKey_Up]:=DorNullProc;
  417.   DorExtKeys[ExtKey_Down]:=DorNullProc;
  418.   ParseParams;
  419.   If Not ReadConfig then
  420.   Begin
  421.     Write('`a15:■ `a7:Could not read config file, returning to `a14:',RaConfig.SystemName);
  422.     Delay(1000);
  423.     Halt;
  424.   End;
  425.   If Not AllocateMem then
  426.   Begin
  427.     Write('`a15:■ `a7:Not enough memory, returning to `a14:',RaConfig.SystemName);
  428.     Delay(1000);
  429.     Halt;
  430.   End;
  431.   Color(7,0);
  432.   ClrScr;
  433.   If DorDisplay(ForceBack(DorPath)+'LAWGATOR.ANS','',FALSE)=#1 then RaLog('GATOR: No background found....');
  434.   If Mailing then CurGroup :=ExitInfo.UserInfo.MsgGroup
  435.   else CurGroup :=ExitInfo.UserInfo.FileGroup;
  436.   If Filing then
  437.   Begin
  438.     If Not AreaOnly then
  439.     Begin
  440.     SelectFileGroup:
  441.       ClearList;
  442.       If not ReadGroups(True) then
  443.       Begin
  444.         Write('`a15:■ `a7:Could not read groups file, returning to `a14:',Raconfig.SystemName);
  445.         Delay(1000);
  446.         Dispose(List);
  447.         Halt;
  448.       End;
  449.       TempResult :=Lister_Selector(Dummy);
  450.       If Dummy=1 then
  451.       Begin
  452.         Dispose(List);
  453.         Halt;
  454.       End;
  455.       If Dummy=0 then ExitInfo.UserInfo.FileGroup :=TempResult;
  456.       CurGroup :=TempResult;
  457.       ClearList;
  458.     End;
  459.     If not ReadFileAreas then
  460.     Begin
  461.       Write('`a15:■ `a7:Could not read area file, returning to `a14:',RaConfig.SystemName);
  462.       Delay(1000);
  463.       Dispose(List);
  464.       Halt;
  465.     End;
  466.     TempResult :=Lister_Selector(Dummy);
  467.     If Dummy=1 then If AreaOnly then
  468.     Begin
  469.       Dispose(List);
  470.       Halt
  471.     End else Goto SelectFileGroup;
  472.     If Dummy=0 then ExitInfo.UserInfo.FileArea :=TempResult;
  473.   End;
  474.   If Mailing then
  475.   Begin
  476.     If Not AreaOnly then
  477.     Begin
  478.     SelectMailGroup:
  479.       ClearList;
  480.       If not ReadGroups(False) then
  481.       Begin
  482.         Write('`a15:■ `a7:Could not read groups file, returning to `a14:',Raconfig.SystemName);
  483.         Delay(1000);
  484.         Dispose(List);
  485.         Halt;
  486.       End;
  487.       TempResult :=Lister_Selector(Dummy);
  488.       if Dummy=1 then
  489.       Begin
  490.         Dispose(List);
  491.         Halt;
  492.       End;
  493.       If Dummy=0 then ExitInfo.UserInfo.MsgGroup :=TempResult;
  494.       CurGroup :=TempResult;
  495.       ClearList;
  496.     End;
  497.     If not ReadMailAreas then
  498.     Begin
  499.       Write('`a15:■ `a7:Could not read area file, returning to `a14:',RaConfig.SystemName);
  500.       Delay(1000);
  501.       Dispose(List);
  502.       Halt;
  503.     End;
  504.     TempResult :=Lister_Selector(Dummy);
  505.     If Dummy=1 then If AreaOnly then
  506.     Begin
  507.       Dispose(List);
  508.       Halt
  509.     End else Goto SelectMailGroup;
  510.     If Dummy=0 then ExitInfo.UserInfo.MsgArea :=TempResult;
  511.   End;
  512.   ClrScr;
  513.   Dispose(List);
  514. End.
  515.  
  516.  
  517.  
  518.  
  519.